#lang errortrace racket

(require "hw5-util.rkt")

; State monad:

(define (eff-bind o1 o2)
  (lambda (h1)
    (define eff-x (o1 h1))
    (define x (eff-result eff-x))
    (define h2 (eff-state eff-x))
    (define new-op (o2 x))
    (new-op h2)))
(define (eff-pure v)
  (lambda (h) (eff h v)))

; Error monad

(define (err-bind v k)
  (define arg1 v)
    (cond
      [(false? v) v]
      [else (k v)]))
(define (err-pure v) v)

; List monad

(define (list-bind op1 op2)
  (join (map op2 op1)))
(define (list-pure x)
  (list x))

(define (join elems)
  (foldr append empty elems))

; 1. Define a monad structure

(struct monad (bind pure))

(define-syntax do-with
  (syntax-rules (<- pure)
    ; Only one monadic-op, return it
    [(_ m (pure mexp)) ((monad-pure m) mexp)]
    [(_ m mexp) mexp]
    ; A binding operation
    [(_ m var <- (pure mexp) rest ...) ((monad-bind m) ((monad-pure m) mexp) (lambda (var) (do-with m rest ...)))]
    [(_ m var <- mexp rest ...) ((monad-bind m) mexp (lambda (var) (do-with m rest ...)))]
    ; No binding operator, just ignore the return value
    [(_ m (pure mexp) rest ...)  ((monad-bind m) ((monad-pure m) mexp) (lambda (_) (do-with m rest ...)))]
    [(_ m mexp rest ...)        ((monad-bind m) mexp (lambda (_) (do-with m rest ...)))]))







; Example 1:

(define list-m (monad list-bind list-pure))
#|
(do-with list-m
  x <- (list 1 2)
  y <- (list 3 4)
  (pure (cons x y)))

|#




; Example 2

(define state-m (monad eff-bind eff-pure))

(define (push n)
  (lambda (s)
    (eff (cons n s) (void))))

(define pop
  (lambda (s)
    (eff (rest s) (first s))))

(define mult
  (do-with state-m
    x <- pop
    y <- pop
    (push (* x y))))

;(mult (list 2 3))






;----------------------------------------
; Type-directed dynamic binding

#|
; Do-notation using ty-bind
(define-syntax do
  (syntax-rules (<-)
    ; Only one monadic-op, return it
    [(_ mexp) mexp]
    ; A binding operation
    [(_ var <- mexp rest ...) (ty-bind mexp (lambda (var) (do rest ...)))]
    ; No binding operator, just ignore the return value
    [(_ mexp rest ...)        (ty-bind mexp (lambda (_) (do rest ...)))]))

(define (ty-bind o1 o2)
  (cond [(eff-op? o1) (eff-bind2 o1 o2)]
        [(optional? o1) (opt-bind o1 o2)]
        [(list? o1) (list-bind o1 o2)]))


(struct optional (data))

(define (opt-bind o1 o2)
  (cond
    [(and (optional? o1) (false? (optional-data o1))) #f]
    [else (o2 (optional-data o1))]))

(define (opt-pure x) (optional x))

(struct eff-op (func) #:transparent)

(define/contract (eff-bind2 o1 o2)
  (-> eff-op? (-> any/c eff-op?) eff-op?)
  (eff-op (lambda (h1)
    (define/contract eff-x eff? ((eff-op-func o1) h1))
    (define x (eff-result eff-x))
    (define h2 (eff-state eff-x))
    (define/contract new-op eff-op? (o2 x))
    ((eff-op-func new-op) h2))))

; Stack machine example

(define pop2 (eff-op pop))
(define (push2 n) (eff-op (push n)))
(define mult2
  (do
    x <- pop2
    y <- pop2
    (push2 (* x y))))

;((eff-op-func mult2) (list 2 3))

|#







; -----------------------------------------------
; Type-directed dynamic dispatch using generics

(require racket/generic)

(define-generics ty-monad
    (dyn-bind ty-monad k))

(define-syntax do
  (syntax-rules (<-)
    ; Only one monadic-op, return it
    [(_ mexp) mexp]
    ; A binding operation
    [(_ var <- mexp rest ...) (dyn-bind mexp (lambda (var) (do rest ...)))]
    ; No binding operator, just ignore the return value
    [(_ mexp rest ...)        (dyn-bind mexp (lambda (_) (do rest ...)))]))

(struct eff-op (func)
    #:methods gen:ty-monad
    [
      (define (dyn-bind o1 o2)
        (eff-op (lambda (h1)
          (define/contract eff-x eff? ((eff-op-func o1) h1))
          (define x (eff-result eff-x))
          (define h2 (eff-state eff-x))
          (define/contract new-op eff-op? (o2 x))
          ((eff-op-func new-op) h2))))
    ])

(define pop2 (eff-op pop))
(define (push2 n) (eff-op (push n)))

(define mult2
  (do
    x <- pop2
    y <- pop2
    (push2 (* x y))))



;((eff-op-func mult2) (list 2 3))








;-----------------------------
; Exceptions in Racket

(define (on-div-by-zero e)
  "asd")

(define (on-error e)
  "bar")

(define (always e) #t)

; (struct r:number (value)) -> r:number?

(with-handlers
  ; Catch exception
  ([exn:fail:contract:divide-by-zero? on-div-by-zero]
   [always on-error])
  ; Try to run this code
  10)











;